Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/jDXEngine 23886812001.psc/jDXEngine.cls

Visual Basic class definition | 2001-08-01 | 8.0 KB | 222 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "jDXEngine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Ahhh... the powerful and might jDXEngine. ;)
'This is meant to be the mother of all the other 'helper' objects that are contained in this project.
'Note that the other objects CAN be used independently, but will probably need a little bit of re-coding
'to make them work alone.  All helper objects should be able to be accessed through jDXEngine, so declaring
'them seperately is quite unneccessary.  If you have any questions/comments on this object, please direct
'them to [e-mail].  In case anone is wondering where the 'j' in jDXEngine comes from, my name
'is 'j'oe, and I've gotten into the habit of prefixing my own personal object classes with j. :)

'Declare DirectX objects needed
Dim DX As DirectX8                  'The mother of all DirectX objects
Dim D3D As Direct3D8                'Handles 3D stuffs
Dim D3DX As D3DX8                   'Helper library for meshes and such (will be implemented next release)
Dim D3DDevice As Direct3DDevice8    'Device to draw upon... (almost anything with a .hWnd property)

'Local class variables for use in rendering
Dim bRunning As Boolean             'Quit rendering when False
Dim BackColor As Long               'Background color of the drawing surface

'Camera object
Dim mCamera As New clsCamera

'Keyboard object
Dim mKeyboard As New clsKeyboard

'Lights object(s)
Dim mLights As New clsLights

'Value of pi (4*atn(1)) for any geometry calculations that may need to be performed
Const mPI = 3.14159265358979

'Vertex type definitions to use
Const FVF_LVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR Or D3DFVF_TEX1)    'Use without lighting
Const FVF_UNLITVERTEX = (D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1)                    'Use with lighting

'Matrices
Dim matWorld As D3DMATRIX   'World matrix... when you rotate this, you rotate the entire world
Dim matProj As D3DMATRIX    'Projection matrix... used to define the 'lens' for the camera
                            'matProj SHOULD be with the camera object, but until I understand it's use
                            'better, it will remain here.
Dim matTemp As D3DMATRIX    'Temporary matrix used in calculations

'Storage for all textures that may be loaded
Dim colTextures As New collection

'Unlit geometry object collection.  Each is it's own 'entity'
Private UnlitGeometry As New collection


'A simple sub to add a clsUnlitObject object to the collection
Public Sub AddGeometry(UnlitGeo As clsUnlitObject)
    UnlitGeometry.Add UnlitGeo
End Sub

'This function will load a texture from a file, and store it into a collection using a programmer-provided
'key to reference it by.  If the function is successful, it will return the reference name of the texture.
'Otherwise, it will return an empty string to indicate failure
'strFileName:       Full path and filename of the image to be loaded
'strTextureName:    Name used to reference this texture
Public Function AddTexture(strFileName As String, strTextureName As String) As String
    On Error GoTo error_h

    'Temporary storage for the texture
    Dim Texture As Direct3DTexture8

    'First make sure the file exists...
    If Dir(strFileName) = "" Then Exit Function

    'Validate the texture name
    If strTextureName = "" Or IsInCollection(colTextures, strTextureName) Then Exit Function

    'Create the texture
    Set Texture = D3DX.CreateTextureFromFile(D3DDevice, strFileName)

    'Make sure that the texture was created properly
    If Texture Is Nothing Then Exit Function

    'Add this texture to the collection
    colTextures.Add Texture, strTextureName

    'If all went well, return the name of the texture
    AddTexture = strTextureName

    Exit Function
error_h:
    Select Case ErrMsg(Err, "jDXEngine.AddTexture(" & strFileName & "," & strTextureName & ")")
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        Case Else
            Exit Function
    End Select
End Function

'This allows programmer-access to the camera object
Property Get Camera() As clsCamera
    Set Camera = mCamera
End Property

'Returns a texture when given the reference name of an existing texture
'This function will return NOTHING if the reference name provided does not exist
Public Function GetTexture(strTexture As String) As Direct3DTexture8
    On Error GoTo error_h

    If IsInCollection(colTextures, strTexture) Then
        Set GetTexture = colTextures(strTexture)
    Else
        Set GetTexture = Nothing
    End If

    Exit Function
error_h:
    Select Case ErrMsg(Err, "jDXEngine.GetTexture(" & strTexture & ")")
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        Case Else
            Exit Function
    End Select
End Function

'This function will determine if an item with a specific key exists within a collection
Private Function IsInCollection(collection As collection, strKey As String) As Boolean
    On Error GoTo error_h

    On Error Resume Next
    Dim X As Direct3DTexture8
    Set X = collection(strKey)
    If Err Then
        Err.Clear
        IsInCollection = False
    Else
        IsInCollection = True
    End If

    Exit Function
error_h:
    Select Case ErrMsg(Err, "jDXEngine.IsInCollection")
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        Case Else
            Exit Function
    End Select
End Function

'r=red value(0-255),g=green,b=blue
Public Function jRGB(r As Integer, g As Integer, b As Integer) As Long
    On Error GoTo error_h

    'I've noticed when working with DX8 that the long color code values it uses
    'are exactly the same as VB's RGB() function except that the R and B values
    'are transposed, so I wrote this little helper function to help out with that.
    jRGB = RGB(b, g, r)

    Exit Function
error_h:
    Select Case ErrMsg(Err, "jDXEngine.DXRGB(" & r & "," & g & "," & b & ")")
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        Case Else
            Exit Function
    End Select
End Function

Public Sub EndRender()
    On Error GoTo error_h

    'All we need to do to stop rendering is set this little variable here to false. :)
    bRunning = False

    Exit Sub
error_h:
    Select Case ErrMsg(Err, "jDXEngine.EndRender")
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        Case Else
            Exit Sub
    End Select
End Sub

'hWnd = the handle to the window that you want to draw in (i THINK it can be anything with a hWnd property, but don't quote me on that)
'HardwareDevice = true if you want to use a 3d accelorator card... false if not
'vtrCamPos = a vector desribing the initial position of the camera
'lngBackColor = the background color when rendering
'blnUseLighting = True to enable lighting
'blnCullCCW = True to enable back-face removal
Public Function InitWindowed(hWnd As Long, HardwareDevice As Boolean, vtrCamPos As D3DVECTOR, lngBackColor As Long, blnUseLighting As Boolean, blnCullCCW As Boolean) As Boolean
    On Error GoTo error_h

    'Boolean values default to false, but just to be safe...
    InitWindowed = False

    'Declare variables to store display information
    Dim d3dpp As D3DPRESENT_PARAMETERS
    Dim DispMode As D3DDISPLAYMODE

    'Create the main 3 objects (D3DX8 is NOT one of the main 3... D3DDevice is the 3rd, but we must configure it first)
    Set DX = New DirectX8
    Set D5 .wAs Btt teust to be safe...
    tosafe textdTigure it B